home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / language / xlispst.cpt / XLisp-Stat ƒ / Disk 1 / common.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1990-08-15  |  10.1 KB  |  304 lines
  1. ;;;;
  2. ;;;; Additional Common Lisp Functions for XLISP-STAT 2.0
  3. ;;;; XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney
  4. ;;;; Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz
  5. ;;;; You may give out copies of this software; for conditions see the file
  6. ;;;; COPYING included with this distribution.
  7. ;;;;
  8.  
  9. (setf (get 'first '*setf*)  #'(lambda (x y) (setf (nth 0 x) y)))
  10. (setf (get 'second '*setf*) #'(lambda (x y) (setf (nth 1 x) y)))
  11. (setf (get 'third '*setf*)  #'(lambda (x y) (setf (nth 2 x) y)))
  12. (setf (get 'fourth '*setf*) #'(lambda (x y) (setf (nth 3 x) y)))
  13.  
  14. ;;;;
  15. ;;;;
  16. ;;;; Defsetf and documentation functions
  17. ;;;;
  18. ;;;;
  19.  
  20. (defun apply-arg-rotate (f args) 
  21.   (apply f (car (last args)) (butlast args)))
  22.  
  23. ; (defsetf) - define setf method
  24. (defmacro defsetf (sym first &rest rest)
  25. "Syntax: (defsetf sym fcn [doc])
  26. Installs #'FCN as setf method for SYM."
  27.   (if (symbolp first)
  28.       `(progn (setf (get ',sym '*setf*) #',first) ',sym)
  29.       (let ((f `#'(lambda ,(append (car rest) first) ,@(cdr rest)))
  30.             (args (gensym)))
  31.         `(progn
  32.           (setf (get ',sym '*setf*) 
  33.                 #'(lambda (&rest ,args) (apply-arg-rotate ,f ,args)))
  34.           ',sym))))
  35.  
  36. ;; (load-help) - read in file positions fo accessing help info.
  37. (defun load-help ()
  38.   (when 
  39.    (and (null *help-loaded*) (streamp *help-stream*))
  40.    (princ "loading in help file information - this will take a minute ...")
  41.    (force-output)
  42.    (setq *help-loaded* t)
  43.    (file-position *help-stream* 0)
  44.    (do ((item (read *help-stream* nil '*eof*) 
  45.               (read *help-stream* nil '*eof*))) 
  46.        ((eq item '*eof*))
  47.        (cond
  48.          ((and item
  49.                (symbolp item) 
  50.                (null (get item 'function-documentation)))
  51.           (setf (get item 'function-documentation) 
  52.                 (file-position *help-stream*)))
  53.          ((consp item)
  54.              (case (cadr item)
  55.                (function (if (null (get (car item) 'function-documentation))
  56.                              (setf (get (car item) 'function-documentation) 
  57.                                   (file-position *help-stream*))))
  58.               (variable (if (null (get (car item) 'variable-documentation))
  59.                              (setf (get (car item) 'variable-documentation) 
  60.                                   (file-position *help-stream*))))
  61.               (type (if (null (get (car item) 'type-documentation))
  62.                          (setf (get (car item) 'type-documentation) 
  63.                               (file-position *help-stream*))))
  64.               (object
  65.                (if (and (boundp (car item))
  66.                         (objectp (symbol-value (car item)))
  67.                         (null (send (symbol-value (car item))
  68.                                     :internal-doc
  69.                                     (caddr item))))
  70.                    (send (symbol-value (car item))
  71.                         :documentation
  72.                         (caddr item)
  73.                         (file-position *help-stream*))))))))
  74.    (princ "done")
  75.    (terpri)))
  76.  
  77. (defun documentation (symbol doc-type)
  78. "Args: (symbol doc-type)
  79. Returns SYMBOL documentation of type DOC-TYPE."
  80.   (load-help)
  81.   (let ((doc  (case doc-type
  82.                 (function (get symbol 'function-documentation))
  83.                 (variable (get symbol 'variable-documentation))
  84.                 (type     (get symbol 'type-documentation))
  85.                 (setf     (get symbol 'setf-documentation)))))
  86.     (when (and (numberp doc) (streamp *help-stream*))
  87.           (file-position *help-stream* doc)
  88.           (setq doc (read *help-stream*)))
  89.     doc))
  90.  
  91. (defsetf documentation (symbol doc-type) (value)
  92.   (case doc-type
  93.     (function (setf (get symbol 'function-documentation) value))
  94.     (variable (setf (get symbol 'variable-documentation) value))
  95.     (type     (setf (get symbol 'type-documentation) value))
  96.     (setf     (setf (get symbol 'setf-documentation) value))))
  97.   
  98. ;;;;
  99. ;;;;
  100. ;;;; Modules, provide and require
  101. ;;;;
  102. ;;;;
  103.  
  104. (defvar *modules*)
  105.     
  106. (defun provide (name)
  107. "Args: (name)
  108. Adds NAME to the list of modules."
  109.   (pushnew name *modules* :test #'equal))
  110.   
  111. (defun require (name &optional (path name))
  112. "Args: (name)
  113. Loads module NAME, unless it has already been loaded. If PATH is supplied it
  114. is used as the file name; otherwise NAME is used. If file NAME is not in the
  115. current directory *default-path* is searched."
  116.   (let ((name (string name))
  117.         (path (string path)))
  118.     (unless (member name *modules* :test #'equal)
  119.             (if (load path)
  120.                 t
  121. #+macintosh     (let ((vol (set-volume)))
  122.                   (unwind-protect (load path)
  123.                                   (set-volume vol)))
  124. #-macintosh     (load (strcat *default-path* path))))))
  125.  
  126. ;;;;
  127. ;;;;
  128. ;;;; Miscellaneous Functions
  129. ;;;;
  130. ;;;;
  131.  
  132. ; setf method for select function
  133. (defsetf select set-select)
  134.  
  135. (defun vectorp (x)
  136. "Args: (m)
  137. Returns T if M is a vector, NIL otherwise."
  138.   (and (arrayp x) (= (array-rank x) 1)))
  139.  
  140. (defun matrixp (x)
  141. "Args: (m)
  142. Returns T if M is a matrix, NIL otherwise."
  143.   (and (arrayp x) (= (array-rank x) 2)))
  144.  
  145. (defun equalp (x y)
  146. "Args: (x y)
  147. Returns T if (equal x y), or x, y are numbers and (= x y), or
  148. x and y are strings and (string-equal x y)."
  149.   (or (equal x y) 
  150.       (and (numberp x) (numberp y) (= x y))
  151.       (and (stringp x) (stringp y) (string-equal x y))))
  152.  
  153. (defun y-or-n-p (&rest args)
  154. "Args: (&rest args)
  155. Prints STRING, if provided,  and reads an answer until an answer of Y or N
  156. is obtained. Returns T for Y, NIL for N."
  157.   (do ((answer nil (read))) ((member answer '(y n)) (eq answer 'y))
  158.     (if args (apply #'format t args))
  159.     (princ " (Y/N)")))
  160.     
  161. (defmacro push (a l)
  162. "Syntax: (push item place)
  163. Pushes ITEM onto list in generalized variable PLACE."
  164.   `(if ,l 
  165.        (let ((temp ,l))
  166.          (rplacd temp (cons (car ,l) (cdr ,l)))
  167.          (rplaca temp ,a))
  168.        (setf ,l (cons ,a NIL))))
  169.  
  170. (defmacro pushnew (a l &rest args)
  171. "Syntax: (push item place &key :test :test-not)
  172. Pushes ITEM onto PLACE if it is not already there."
  173.   `(unless (member ,a ,l ,@args) (push ,a ,l) nil))
  174.  
  175. (defun getf (place indicator &optional default)
  176. "Args: (place indicator &optional default)
  177. Returns property value of INDICATOR in PLACE, or DEFAULT if not found."
  178.   (let ((mem (member indicator place :test #'eq)))
  179.     (if mem (second mem) default)))
  180.  
  181. (defun functionp (x)
  182. "Args: (x)
  183. Returns T if X is a legal argument to FUNCALL, NIL otherwise."
  184.     (or (eq (type-of x) 'closure)
  185.         (eq (type-of x) 'subr)
  186.         (symbolp x)
  187.         (and (consp x) (eq (car x) 'lambda))))
  188.  
  189. (defun count (x seq &key (test #'eql))
  190. "Args (x seq &key (test #'eql))
  191. Counts the number of times X occurs in SEQ, using TEST for matching."
  192.   (reduce #'(lambda (sum y) (if (funcall test x y) (+ sum 1) sum)) 
  193.           seq :initial-value 0))
  194.  
  195. (defmacro with-input-from-string (stream-string &rest body)
  196. "Syntax: (with-input-from-string (stream string) {form}*)
  197. Opens stream for reading from STRING, binds to STREAM and evaluates
  198. FORMs with this binding."
  199.   (let ((stream (first stream-string))
  200.         (string (second stream-string)))
  201.     `(let ((,stream (make-string-input-stream ,string)))
  202.        (progn ,@body))))
  203.  
  204. (defmacro with-output-to-string (str-list &rest body)
  205. "Syntax: (with-output-to-string (stream) {form}*)
  206. Opens string output stream, binds to STREAM and evaluates FORMs with
  207. this binding. Returns output stream string."
  208.   (let ((stream (first str-list)))
  209.     `(let ((,stream (make-string-output-stream)))
  210.        (progn ,@body)
  211.        (get-output-stream-string ,stream))))
  212.  
  213. (defmacro with-open-file (stream-file-args &rest body)
  214. "Syntax: (with-open-file (stream filename {options}*) {form}*)
  215. Opens file stream for FILENAME with specified options, binds to 
  216. STREAM and evaluates FORMs with this binding. Closes stream regardless
  217. of errors."
  218.   (let ((stream (first stream-file-args))
  219.     (file-args (rest stream-file-args)))
  220.     `(let ((,stream (open ,@file-args)))
  221.        (unwind-protect 
  222.        (progn ,@body)
  223.      (if ,stream (close ,stream))))))
  224.  
  225. (defun realp (x)
  226. "Args: (x)
  227. Returns true if X is a real number."
  228.   (or (integerp x) (floatp x)))
  229.  
  230. ;;;;
  231. ;;;;
  232. ;;;; Additional Common Lisp Functions for Xlisp 2.0
  233. ;;;; From the init.lsp file supplied in the Xlisp distribution
  234. ;;;;
  235. ;;;;
  236.  
  237. ; (unintern sym) - remove a symbol from the oblist
  238. (defun unintern (symbol)
  239. "Args: (symbol)
  240. Makes SYMBOL no longer present in *OBARRAY*.  Returns T if SYMBOL was present;
  241. NIL otherwise."
  242.   (let ((subhash (hash symbol (length *obarray*))))
  243.     (cond ((member symbol (aref *obarray* subhash))
  244.              (setf (aref *obarray* subhash)
  245.                    (delete symbol (aref *obarray* subhash)))
  246.              t)
  247.           (t nil))))
  248.  
  249. ; (mapcan fun list [ list ]...)
  250. (defmacro mapcan (&rest args) `(apply #'nconc (mapcar ,@args)))
  251.  
  252. ; (mapcon fun list [ list ]...)
  253. (defmacro mapcon (&rest args) `(apply #'nconc (maplist ,@args)))
  254.  
  255. ; (set-macro-character ch fun [ tflag ])
  256. (defun set-macro-character (ch fun &optional tflag)
  257.     (setf (aref *readtable* (char-int ch))
  258.           (cons (if tflag :tmacro :nmacro) fun))
  259.     t)
  260.  
  261. ; (get-macro-character ch)
  262. (defun get-macro-character (ch)
  263.   (if (consp (aref *readtable* (char-int ch)))
  264.     (cdr (aref *readtable* (char-int ch)))
  265.     nil))
  266.  
  267. ;;;;
  268. ;;;;
  269. ;;;; Additional System Functions for Xlisp 2.0
  270. ;;;; From the init.lsp file supplied in the Xlisp distribution
  271. ;;;;
  272. ;;;;
  273.  
  274. ; (savefun fun) - save a function definition to a file
  275. (defmacro savefun (fun)
  276. "Args: (fun)
  277. Safe function definition of symbol FUN to file FUN.lsp."
  278.   `(let* ((fname (strcat (symbol-name ',fun) ".lsp"))
  279.           (fval (get-lambda-expression (symbol-function ',fun)))
  280.           (fp (open fname :direction :output)))
  281.      (cond (fp (print (cons (if (eq (car fval) 'lambda)
  282.                                 'defun
  283.                                 'defmacro)
  284.                             (cons ',fun (cdr fval))) fp)
  285.                (close fp)
  286.                fname)
  287.            (t nil))))
  288.  
  289. ; (debug) - enable debug breaks
  290. (defun debug () 
  291. "Args: ()
  292. Enable breaking on error on."
  293.   (setq *breakenable* t))
  294.  
  295. ; (nodebug) - disable debug breaks
  296. (defun nodebug ()
  297. "Args: ()
  298. Disable breaking on error on."
  299.   (setq *breakenable* nil))
  300.  
  301. ; (untrace) - patched to allow zero arguments
  302. #+xlisp (setf (symbol-function '|untrace|) (symbol-function 'untrace))
  303. #+xlisp (defmacro untrace (&rest args) `(|untrace| ,@(if args args (trace))))
  304.